home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / gfaxpert.lzh / GFAXPERT.LIB / STANLOW.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  7.5 KB  |  275 lines
  1. ' *** STANLOW.LST ***           (delete this line)
  2. '
  3. ' ==============================================================================
  4. ' ********************
  5. ' ***         .GFA ***
  6. ' ********************
  7. ' *** this program runs in Low resolution only
  8. '
  9. ' ------------------------------------------------------------------------------
  10. '                             *** Initiation ***
  11. '
  12. DEFWRD "a-z"                    ! word variables (-32768 to +32767) default !!
  13. @initio
  14. '
  15. ' @title.screen("TITLE",".. .... 1990",32)        ! activate in finished program
  16. ' ON BREAK GOSUB break                            ! activate in finished program
  17. '
  18. ' ------------------------------------------------------------------------------
  19. '                            *** Main Program ***
  20. '
  21. '
  22. '
  23. EDIT                            ! use this while developing program
  24. ' @exit                         ! use this in finished program
  25. '
  26. ' ------------------------------------------------------------------------------
  27. '                     *** Standard Globals and Array ***
  28. '
  29. > PROCEDURE initio
  30.   LOCAL w,h,n
  31.   '
  32.   CLS
  33.   @low.mode
  34.   '
  35.   @get.path(default.path$)
  36.   '
  37.   physbase%=XBIOS(2)            ! physical screen
  38.   logbase%=XBIOS(3)             ! logical screen
  39.   '
  40.   low.res!=TRUE
  41.   scrn.x.max=WORK_OUT(0)                              ! 319 (regular monitor)
  42.   scrn.y.max=WORK_OUT(1)                              ! 199
  43.   ~GRAF_HANDLE(char.width,char.height,w,h)            ! 8x8 font
  44.   scrn.col.max=DIV(SUCC(scrn.x.max),char.width)       ! 40
  45.   scrn.lin.max=DIV(SUCC(scrn.y.max),char.height)      ! 25
  46.   '
  47.   white=0             ! default Low colors
  48.   black=1
  49.   red=2
  50.   green=3
  51.   blue=4
  52.   d.blue=5
  53.   brown=6
  54.   d.green=7
  55.   grey=8
  56.   l.black=9
  57.   l.blue=10
  58.   bluegreen=11
  59.   l.purple=12
  60.   d.purple=13
  61.   d.yellow=14
  62.   l.yellow=15
  63.   DEFTEXT black,0,0,6
  64.   '
  65.   ' *** Standard Array color.index()
  66.   ' *** use this array to convert a VDI color-index into a 'SETCOLOR'-index
  67.   RESTORE col.index.low
  68.   DIM color.index(15)
  69.   FOR n=0 TO 15
  70.     READ color.index(n)
  71.   NEXT n
  72.   @standard.low.colors
  73.   '
  74.   col.index.low:
  75.   DATA 0,15,1,2,4,6,3,5,7,8,9,10,12,14,11,13
  76.   '
  77.   on!=TRUE
  78.   off!=FALSE
  79.   '
  80.   bel$=CHR$(7)
  81.   '
  82.   return$=CHR$(13)
  83.   esc$=CHR$(27)
  84.   help$=CHR$(0)+CHR$(98)
  85.   undo$=CHR$(0)+CHR$(97)
  86.   '
  87.   interpreter$="\GFABASIC.PRG"  ! change path if necessary
  88.   run.only$="\GFABASRO.PRG"     ! Run-Only Interpreter
  89.   start.gfa$="\STARTLOW.GFA"    ! 'Shell' for GFA-programs (Low rez)
  90.   start.prg$="\GFASTART.PRG"    ! 'Shell' for compiled GFA-programs
  91.   '
  92. RETURN
  93. ' **********
  94. '
  95. ' ------------------------------------------------------------------------------
  96. '                          *** Standard Functions ***
  97. '
  98. DEFFN center$(text$)=SPACE$((scrn.col.max-LEN(text$))/2)+text$
  99. DEFFN rev$(txt$)=CHR$(27)+"p"+txt$+CHR$(27)+"q"
  100. DEFFN ink$(color)=CHR$(27)+"b"+CHR$(color.index(color))
  101. DEFFN paper$(color)=CHR$(27)+"c"+CHR$(color.index(color))
  102. '
  103. ' ------------------------------------------------------------------------------
  104. '                         *** Standard Procedures ***
  105. '
  106. > PROCEDURE low.mode
  107.   LOCAL m$,button
  108.   IF XBIOS(4)<>0
  109.     SOUND 1,10,12,4,25
  110.     SOUND 1,10,6,4,25
  111.     SOUND 1,10,12,4,50
  112.     SOUND 1,0
  113.     m$="Sorry, you should|use Low resolution|for this program"
  114.     ALERT 3,m$,1," OK ",button
  115.     @exit
  116.   ENDIF
  117. RETURN
  118. ' **********
  119. '
  120. > PROCEDURE get.path(VAR default.path$)
  121.   ' *** return default path (current drive and folder)
  122.   ' *** example - A:\GAMES\
  123.   ' *** WARNING : Procedure returns path$ only after CHDIR path$, else A:\
  124.   ' ***                          (even if program not in main directory !!)
  125.   LOCAL default.drive,default.drive$
  126.   CLR default.path$
  127.   default.drive=GEMDOS(&H19)
  128.   default.drive$=CHR$(default.drive+65)
  129.   default.path$=DIR$(default.drive+1)
  130.   IF default.path$<>""
  131.     default.path$=default.drive$+":"+default.path$+"\"
  132.   ELSE
  133.     default.path$=default.drive$+":\"
  134.   ENDIF
  135. RETURN
  136. ' **********
  137. '
  138. > PROCEDURE standard.low.colors
  139.   ' *** standard-colors for Low resolution
  140.   LOCAL n,col$,r,g,b
  141.   RESTORE col.data
  142.   FOR n=0 TO 15
  143.     READ col$
  144.     r=VAL(LEFT$(col$))
  145.     g=VAL(MID$(col$,2,1))
  146.     b=VAL(RIGHT$(col$))
  147.     VSETCOLOR n,r,g,b
  148.   NEXT n
  149.   '
  150.   col.data:
  151.   DATA 777,000,700,060,007,005,520,050,555,111,077,053,707,505,550,770
  152. RETURN
  153. ' **********
  154. '
  155. > PROCEDURE title.screen(title$,datum$,height)
  156.   ' *** standard title-screen
  157.   ' *** uses Standard Globals and Standard Procedure Return.key
  158.   LOCAL x,y,col,lin,name$,x1,y1,x2,y2,i
  159.   CLS
  160.   HIDEM
  161.   DEFTEXT black,8,0,height
  162.   x=(scrn.x.max-LEN(title$)*height/2)/2
  163.   y=scrn.y.max/2
  164.   TEXT x,y,title$
  165.   LET name$="© Han Kempen"      ! that's me
  166.   col=(scrn.col.max-12)/2
  167.   lin=scrn.lin.max/2+6
  168.   PRINT AT(col,lin);name$
  169.   x1=(col-2)*8
  170.   y1=(lin-1)*char.height-4
  171.   x2=x1+LEN(name$)*8+16
  172.   y2=y1+char.height+8
  173.   BOX x1,y1,x2,y2
  174.   DEFLINE 1,3
  175.   DRAW x1+3,y2+2 TO x2+2,y2+2 TO x2+2,y1+3
  176.   LINE x1+3,y2+1,x2+2,y2+1
  177.   PRINT AT(col,lin+2);datum$
  178.   @return.key
  179.   COLOR black
  180.   DEFLINE 1,1
  181.   FOR i=0 TO y
  182.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  183.   NEXT i
  184.   COLOR white
  185.   FOR i=y DOWNTO 0
  186.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  187.   NEXT i
  188.   COLOR black
  189.   CLS
  190. RETURN
  191. ' **********
  192. '
  193. > PROCEDURE return.key
  194.   ' *** wait for <Return>
  195.   ' *** after pressing any other key, flashing 'RETURN' is turned off
  196.   ' *** uses Standard Globals
  197.   LOCAL w1$,w2$,temp$,in$
  198.   CLR in$
  199.   REPEAT
  200.   UNTIL INKEY$=""
  201.   GET 0,scrn.y.max-char.height,scrn.x.max,scrn.y.max,temp$
  202.   w1$="<RETURN>"
  203.   w2$=SPACE$(8)
  204.   PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  205.   WHILE in$=""                              ! wait for any key
  206.     PAUSE 30
  207.     SWAP w1$,w2$
  208.     PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  209.     in$=INKEY$
  210.   WEND
  211.   PUT 0,scrn.y.max-char.height,temp$,3    ! restore screen
  212.   WHILE in$<>return$                      ! wait for <Return>
  213.     in$=INKEY$
  214.   WEND
  215. RETURN
  216. ' **********
  217. '
  218. > PROCEDURE break
  219.   ' *** activate in main program with : ON BREAK GOSUB break
  220.   ' *** do not use while developing program !
  221.   LOCAL m$,k
  222.   ON BREAK CONT
  223.   m$="*** Break ***|Continue,|Run again|or Quit"
  224.   ALERT 3,m$,1,"CONT|RUN|QUIT",k
  225.   SELECT k
  226.   CASE 1
  227.     ON BREAK                            ! true break possible for emergency
  228.     m$="Freeze current|screen (press|any key to|continue)"
  229.     ALERT 2,m$,2,"YES|NO",k
  230.     IF k=1
  231.       REPEAT
  232.       UNTIL LEN(INKEY$) OR MOUSEK
  233.     ENDIF
  234.     ON BREAK GOSUB break
  235.   CASE 2
  236.     RUN
  237.   CASE 3
  238.     @exit
  239.   ENDSELECT
  240. RETURN
  241. ' **********
  242. '
  243. > PROCEDURE exit
  244.   ' *** exit program
  245.   CLS
  246.   IF EXIST(interpreter$) OR EXIST(run.only$)
  247.     ' *** program was run from (Run-Only) Interpreter
  248.     IF EXIST(start.gfa$)
  249.       CHAIN start.gfa$          ! back to 'shell'-program
  250.     ELSE
  251.       EDIT                      ! no shell
  252.     ENDIF
  253.   ELSE IF EXIST(start.gfa$)
  254.     ' *** can't find interpreter, but here is the 'shell'-program
  255.     CHAIN start.gfa$
  256.   ELSE IF EXIST(start.prg$)
  257.     ' *** compiled program started from shell
  258.     CHAIN start.prg$            ! back to shell
  259.   ELSE
  260.     ' *** compiled program
  261.     SYSTEM                      ! no shell
  262.   ENDIF
  263. RETURN
  264. ' **********
  265. '
  266. ' ------------------------------------------------------------------------------
  267. '                               *** Procedures ***
  268. '
  269. '
  270. '
  271. '
  272. ' ------------------------------------------------------------------------------
  273. '                                *** The End ***
  274. ' ==============================================================================
  275.